home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / trace.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  2KB  |  76 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;  EuLisp Module                     Copyright (C) University of Bath 1991  ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;
  9. ;; Simple tracing facility
  10. ;;
  11. ;; (trace-bindings symbol1 symbol2 ... symboln) causes the symbols to be
  12. ;; traced, printing arguments on entry and result on exit.
  13. ;;
  14. ;; (untrace-bindings symbol1 symbol2 ... symboln) causes the symbols to be
  15. ;; retored to their original state.
  16. ;;
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18.  
  19. (defmodule trace
  20.  
  21.   (standard) ()
  22.  
  23.   (defstruct traced-fn ()
  24.     ((fn 
  25.        initarg fn
  26.        accessor traced-fn-fn))
  27.     constructor make-traced-fn)
  28.  
  29.   (deflocal *trace-table* (make-table eq))
  30.  
  31.   (defun trace-indent (n char)
  32.     (if (= n 0) (prin char (trace-output-stream))
  33.       (progn
  34.     (prin char (trace-output-stream))
  35.     (trace-indent (- n 1) char))))
  36.  
  37.   (defmacro trace-bindings name-list
  38.     `(progn
  39.        ,@(mapcar 
  40.        (lambda (name) 
  41.              `(progn
  42.         (deflocal ,name
  43.           (let ((value (make-traced-fn 'fn ,name))
  44.             (level 0))
  45.             ((setter table-ref) *trace-table* ',name value)
  46.             (lambda args 
  47.               (let ((ret ()))
  48.             (format (trace-output-stream) "~a:" ',name)
  49.             (trace-indent level #\>)
  50.             (format (trace-output-stream) " ~a~%" args)
  51.             (setq level (+ level 1))
  52.                         (unwind-protect
  53.                           (progn
  54.                             (setq ret (apply (traced-fn-fn value) args))
  55.                 (format (trace-output-stream) "~a:" ',name)
  56.                 (trace-indent (- level 1) #\<)
  57.                 (format (trace-output-stream) " ~a~%" ret))
  58.               (setq level (- level 1))
  59.               ret)))))))
  60.          name-list)))
  61.  
  62.   (defmacro untrace-bindings name-list
  63.     `(progn
  64.        ,@(mapcar
  65.        (lambda (name)
  66.          `(progn
  67.         (deflocal ,name 
  68.           (traced-fn-fn (table-ref *trace-table* ',name)))
  69.         ((setter table-ref) *trace-table* ',name nil)))
  70.        name-list)))
  71.  
  72.   (export trace-bindings untrace-bindings traced-fn 
  73.       traced-fn-fn make-traced-fn *trace-table* trace-indent)
  74.  
  75. )
  76.